Shareware Grab Bag/Shareware Grab Bag.iso/090/byt86feb.arc/VISUAL.LBR/XLISPVSD

Text File | 1986-04-11 | 6KB | 535 lines

; BYSO Visual Syntax Editor-Limited Version

; Copyright (C) 1985 Raphael L. Levien

; ALL RIGHTS RESERVED



; Converted for XLISP version 1.5c on the IBM-PC by David Betz



(putprop 'defun 'defund 'vsd)

(putprop 'quote 'quoted 'vsd)



(setq *he* nil)



(defun vsd (l)

 (let ((old-he *he*))

  (clear)

  (setq *he* (gensym))

  (vsd1 l 160)

  (setq *he* old-he)

  (setc 3360)))



(defun vsd1 (l p)

 (if (eq *he* l)

  (highlt l p)

  (if (consp l)

   (if (and (symbolp (car l)) (get (car l) 'vsd))

    (funcall (get (car l) 'vsd) l p)

    (adj

     (car l)

     p

     (vsd4 (cdr l) (vsd3 (car l) p))))

   (vsd2 l p))))



(defun vsd2 (l p)

 (prog1

  (setc (- p (* (flatc l) 2)))

  (princ l)))


(defun vsd3 (a p)

 (let* ((sl (flatc a))

    (b (- p (+ sl sl 4))))

  (setc b)

  (write-char 218)

  (dotimes (i sl) (write-char 196))

  (write-char 191)

  (setc (+ 160 b))

  (write-char 179)

  (princ a)

  (write-char 195)

  (setc (+ b 320))

  (write-char 192)

  (dotimes (i sl) (write-char 196))

  (write-char 217)

  b))



(defun adj (a p h)

 (let* ((sl (flatc a))

    (b (- p (+ sl sl -316)))

    (top (- (max b (car h)) 160)))

  (setc (do ((i b (+ i 160)))

         ((> i top) i)

     (setc i)

     (write-char 179)

     (dotimes (i sl) (write-char 32))

     (write-char 179)))

  (write-char 192)

  (dotimes (i sl) (write-char 196))

  (write-char 217)

  (max b (- (cdr h) 160))))



(defun vsd4 (a p)

 (do ((l a (cdr l))

      (c p))

  ((null l)

   (cons (+ c 160)

    p))

  (setc (setq c (+ p (if (consp (car l))

              156

              -4))))

  (write-char 196)

  (write-char 26)

  (setq p (+ (* 160 (/ (vsd1 (car l)

            (- p 4))

             160))

       (rem p 160)

       160))))



(defun defund (l p)

 (setc 0)

 (msg "Function: " (cadr l)

  t

  "Variables:")

 (if (and (nth 2 l)

      (atom (nth 2 l)))

  (setq l (cdr l)))

 (do ((tl (nth 2 l)

       (cdr tl)))

  ((null tl))

  (msg " " (car tl)))

 (vsd1 (if (nthcdr 4 l)

    (cons 'progn (nthcdr 3 l))

    (nth 3 l))

  p))



(defun quoted (l p)

 (vsd2 (cadr l)

  (+ 160 p)))



(defun highlt (l p)

 (let ((old-he *he*))

  (let (r)

   (set-inverse t)

   (setq *he* (gensym))

   (setq r (vsd1 l p))

   (setq *he* old-he)

   (set-inverse nil)

   r)))



(defun in (x y)

 (if (null y)

  x

  (nth (car y)

   (in x (cdr y)))))



(defun ins (z y v)

 (if (null y)

  (setq *x* v)

  (setf (nth (car y)

     (in z (cdr y)))

   v)))



(defun edv (x)

 (prog (com)

  (setq *x* (subst nil nil x)

    *curs*

      (if (and (consp *x*)

           (eq (car *x*)

               'defun))

          (list (if (and (nth 2 *x*)

                 (atom (nth 2 *x*)))

            4

            3))

          nil))

  (clear)

  a

  (dhlt *x*)

  (setq com (get-key))

  (if (= com 27)    ; escape

   (stoped))

  (if (= com 200)    ; up

   (if *curs* (setf (car *curs*) (1- (car *curs*)))))

  (if (= com 203)    ; left

   (setq *curs* (cons 1 *curs*)))

  (if (= com 205)    ; right

   (setq *curs* (cdr *curs*)))

  (if (= com 208)    ; down

   (if *curs* (setf (car *curs*) (1+ (car *curs*)))))

  (if (= com 99)    ; (c)hange

   (chel))

  (if (= com 97)    ; (a)dd

   (addarg))

  (if (= com 105)    ; (i)nsert

   (inel))

  (if (= com 100)    ; (d)elete

   (delel))

  (if (= com 116)    ; (t)est

   (testel))

  (go a)))



(defun dhlt (l)

  (let ((old-he *he*))

    (setq *he* (in l *curs*))

    (vsd1 l 160)

    (setq *he* old-he)

    (setc 3360)))



(defun chel ()

  (msg "Change to")

  (ins *x* *curs* (readel "Change to: "))

  (clear))



(defun readel (m)

  (msg " a)tom or f)unction? ")

  (if (= (get-key) 102)

    (progn

      (msg "function" t m)

      (list (read)))

    (progn

      (msg "atom" t m)

      (read))))



(defun addarg ()

  (msg "Add argument")

  (setf (cdr (last (in *x* *curs*)))

    (list (readel "Argument: ")))

  (clear))



(defun inel ()

  (when *curs*

    (msg "Insert")

    (setf (cdr (nthcdr (1- (car *curs*))

               (in *x* (cdr *curs*))))

      (cons (readel "Insert: ")

        (nthcdr (car *curs*)

            (in *x* (cdr *curs*)))))

    (clear)))



(defun delel ()

  (when *curs*

    (setf (cdr (nthcdr (1- (car *curs*))

               (in *x* (cdr *curs*))))

      (nthcdr (1+ (car *curs*))

          (in *x* (cdr *curs*))))

    (if (not (nthcdr (car *curs*)

             (in *x* (cdr *curs*))))

      (if (= (car *curs*) 1)


    (setq *curs* (cdr *curs*))

    (setf (car *curs*) (1- (car *curs*)))))

    (clear)))



(defun testexp (exp)

  (prog (val)

    (setq val (eval exp))

    (msg "Value: ")

    (print val)

    (msg "Press any key to return to editor: ")

    (get-key)

    (clear)))



(defun testel ()

  (if *curs*

    (progn

      (msg "w)hole display or h)ighlighted area? ")

      (if (= (get-key) 104)

    (progn

      (msg "highlighted area" t)

      (testexp (in *x* *curs*)))

    (progn

      (msg "whole display" t)

      (testexp *x*))))

    (testexp *x*)))



(defun stoped ()

  (msg "Are you sure you want to exit the editor? ")

  (if (= (get-key) 121)

    (progn

      (terpri)

      (return *x*))

  (clear)))



(defun ask (m)

  (msg m)

  (read))



; functions required for XLISP



(defun setc (p)

  (set-cursor (/ p 160) (rem (/ p 2) 80))

  p)



(defun msg (&rest args)

  (mapcar #'(lambda (x) (if (eq x t) (terpri) (princ x)))

      args))



(expand 1)





(defun msg (&rest args)

  (mapcar #'(lambda (x) (if (eq x t) (terpri) (princ x)))